Option Explicit

Const cGebizPath="\\192.168.83.34\tools\wenwei\gebiz"
'Const cGebizPath = "\\ncsfesg05\gebiz"
'Const cGebizPath = "\\Vegas\ncstore\ATLANTA\CRM\GeBiz Script - Bid Office\Testing"

Const cHttpLink = "http://gebiz.ncs.com.sg/"

Const cMaxAttachFiles = 6

'vb flags
Const ForReading = 1

Dim arrGebizXL(1,6)

'Strings to be put in excel as headers
arrGebizXL(0,0) = "Sorted" & vbLF & "By Biz Ctr"
arrGebizXL(0,1) = "Calling Entity Name"
arrGebizXL(0,2) = "Quotation Ref"
arrGebizXL(0,3) = "Description"
'arrGebizXL(0,4) = "Service Type"
arrGebizXL(0,4) = "Publication" & vbLF & "Date/Time"
arrGebizXL(0,5) = "Closing" & vbLF & "Date/Time"
arrGebizXL(0,6) = "ITQ Content"
'arrGebizXL(0,8) = "Entity"
'arrGebizXL(0,9) = "Corrigendum"

arrGebizXL(1,0) = "A4"
arrGebizXL(1,1) = "B4"
arrGebizXL(1,2) = "C4"
arrGebizXL(1,3) = "D4"
arrGebizXL(1,4) = "E4"
arrGebizXL(1,5) = "F4"
arrGebizXL(1,6) = "G4"
'arrGebizXL(1,7) = "H4"
'arrGebizXL(1,8) = "I4"
'arrGebizXL(1,9) = "J4"

Const cXLColForRelatedDocs = 72

Dim strSourcePath, oFSO, oSrcFolders, oDesFile, oFileName, strDesDrive, strDesFolder, oDesFolders, oDesWorkingFolder

'Get user folder where the files Gebiz files were downloaded
strSourcePath = GetUserInput()

If strSourcePath = "" Then
	MsgBox "You've not chosen the folder location of your Gebiz files, click OK to terminate the operation."
	WScript.Quit
End If

strDesDrive = MapFreeDrive(cGebizPath, False, Null, Null)

If IsNull(strDesDrive) Then
		MsgBox "Error accessing NCS Gebiz server"
		WScript.Quit
End If

Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set oSrcFolders = oFSO.GetFolder(strSourcePath)
Set oDesFolders = oFSO.GetFolder(strDesDrive) 

strDesFolder = InitializeDesFolder(oFSO, oSrcFolders, oDesFolders)
'strDesFolder =  InitializeTestFolder(oFSO, oSrcFolders, oDesFolders) ' For testing purpose only

Set oDesWorkingFolder = oFSO.GetFolder(strDesFolder)
Set oDesFile = oDesWorkingFolder.Files

Dim appXL, appBook, index

Set appXL = WScript.CreateObject("Excel.Application")
Set appBook = appXL.Workbooks.Add()


'Initialise excel worksheet headers
'Put in Legend 
appXL.ActiveSheet.Range("A1").Value = "Legend:"
appXL.ActiveSheet.Range("A1").Font.Size = 12
appXL.ActiveSheet.Range("A1").Font.Bold = True

appXL.ActiveSheet.Range("A2").Value = "Received separate email alert from customer thru gebiz to notify us on their ITQ publication notice and specific invitation to participate."
appXL.ActiveSheet.Range("A2").Font.Size = 10
appXL.ActiveSheet.Range("A2").Font.Bold = False
appXL.ActiveSheet.Range("A2").Interior.ColorIndex = 20

appXL.ActiveSheet.Range("A3").Value = "RFQ has been forwarded to TS (ICT) grp (Ann or Chee Kwong) or MS grp prior to this announcement"
appXL.ActiveSheet.Range("A3").Font.Size = 10
appXL.ActiveSheet.Range("A3").Font.Bold = False
appXL.ActiveSheet.Range("A3").Interior.ColorIndex = 40


For index = 0 to UBound(arrGebizXL,2)
		appXL.ActiveSheet.Range(arrGebizXL(1,index)).Value = arrGebizXL(0,index)
		appXL.ActiveSheet.Range(arrGebizXL(1,index)).Font.Size = 10
		appXL.ActiveSheet.Range(arrGebizXL(1,index)).Font.Bold = True
		appXL.ActiveSheet.Range(arrGebizXL(1,index)).Interior.ColorIndex = 6
Next


Dim oHTMLFile, strHTMLContents, arrValues(), intRow, intStart, strCurrentCell


Dim arrAttachments(), intMaxAttachments, intColumnPointer

'Enumerate all downloaded document attachments in ITQ
intMaxAttachments = GetAttachments(arrAttachments, oDesWorkingFolder)

intColumnPointer = cXLColForRelatedDocs - 1
'Initialise excel worsheet headers for downloaded documents
If intMaxAttachments > 0 Then
	For index = 1 To intMaxAttachments
		 intColumnPointer = intColumnPointer + 1
		 If intColumnPointer > Asc("Z") Then
			Exit For
		 End If
		 appXL.ActiveSheet.Range(Chr(intColumnPointer) & "4").Value = "Attachment " & index
		 appXL.ActiveSheet.Range(Chr(intColumnPointer) & "4").Font.Size = 10
		 appXL.ActiveSheet.Range(Chr(intColumnPointer) & "4").Font.Bold = True
		 appXL.ActiveSheet.Range(Chr(intColumnPointer) & "4").Interior.ColorIndex = 6

	Next
End If

intRow = 5
index = 0

'Search for htm or html files on server. Note that server was choosen as its easier to get the http relative path
For Each oFileName In oDesFile
	If (IsHTML(oFileName.Name)) Then
		On Error Resume Next
		Set oHTMLFile = oFSO.OpenTextFile(strSourcePath & "\" & oFileName.Name)
		
		If Err.number <> 0 Then
			'File found on server but not downloaded to hardrive
			'MsgBox "Warning: File," & oFileName.Name & " ,found on NCS Gebiz server (\\spartan2\gebiz) was not found in the folders where you downloaded on your computer. Someone could have ran the script before you."
		Else
			strHTMLContents = Normalise(oHTMLFile.ReadAll)
		
			intStart = FindString(1, "Details", strHTMLContents)
		
			If Not(IsNull(intStart)) Then
			
				Dim strTemp
			
				'Insert NCS Applicable Entity in excel file
'				strCurrentCell = Mid(arrGebizXL(1,8),1,1) + CStr(intRow)
'				appXL.ActiveSheet.Range(strCurrentCell).Value = "NCS & NCSCE"
				
				'Get ITQ No.
				Dim ITQ
				
				intStart = FindString(intStart, "ITQ No.", strHTMLContents)
				If Not (IsNull(intStart)) Then
					strTemp = GetCellValue(intStart, strHTMLContents)
					If strTemp <> "" Then
						ITQ = strTemp
						strCurrentCell = Mid(arrGebizXL(1,2),1,1) + CStr(intRow)
						appXL.ActiveSheet.Range(strCurrentCell).Value = strTemp
						appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
						strTemp = ""
					End If
				End If
				
				'Insert Details hyperlink
				strTemp = "=HYPERLINK(" & Chr(34) & cHttpLink & ConvertToRelativePath(oFileName.ParentFolder.Path) & "/" & oFileName.Name & Chr(34) & "," & Chr(34) & ITQ & Chr(34) & ")" 
				strCurrentCell = Mid(arrGebizXL(1,6),1,1) + CStr(intRow)
				appXL.ActiveSheet.Range(strCurrentCell).Formula = strTemp
				appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
			
				'Get Publication Date
				intStart = FindString(intStart, "Publication Date", strHTMLContents)
				If Not (IsNull(intStart)) Then
					strTemp = GetCellValue(intStart, strHTMLContents)
					If strTemp <> "" Then
						strCurrentCell = Mid(arrGebizXL(1,4),1,1) + CStr(intRow)
						appXL.ActiveSheet.Range(strCurrentCell).Value = FormatDateTime(strTemp)
						appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
						strTemp = ""
					End If
				End If
			
	
				'Get Description
				intStart = FindString(intStart, "Description", strHTMLContents)
				If Not (IsNull(intStart)) Then
					strTemp = GetCellValue(intStart, strHTMLContents)
					If strTemp <> "" Then
						strCurrentCell = Mid(arrGebizXL(1,3),1,1) + CStr(intRow)
						appXL.ActiveSheet.Range(strCurrentCell).Value = WrapText(strTemp, 40)
						appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
						strTemp = ""
					End If
				End If
			
				'Get Closing Date and Time
				intStart = FindString(intStart, "Closing Date and Time", strHTMLContents)
				If Not (IsNull(intStart)) Then
					strTemp = GetCellValue(intStart, strHTMLContents)
					If strTemp <> "" Then
						strCurrentCell = Mid(arrGebizXL(1,5),1,1) + CStr(intRow)
						appXL.ActiveSheet.Range(strCurrentCell).Value = FormatDateTime(strTemp)
						appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
						strTemp = ""
					End If
				End If
				
				'Identity Corrigendum
'				intStart = FindString(intStart, "Corrigendum", strHTMLContents)
'				If Not (IsNull(intStart)) Then
'					strTemp = "Corrigendum"
'					If strTemp <> "" Then
'						strCurrentCell = Mid(arrGebizXL(1,9),1,1) + CStr(intRow)
'						appXL.ActiveSheet.Range(strCurrentCell).Value = strTemp
'						appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
'						strTemp = ""
'					End If
'				End If

				'Get Calling Entity Name
				intStart = FindString(1, "CALLING ENTITY", strHTMLContents)
				If Not (IsNull(intStart)) Then
					intStart = FindString(intStart, "Name", strHTMLContents)
					If Not (IsNull(intStart)) Then
						strTemp = WrapText(GetCellValue(intStart, strHTMLContents), 20)
						If strTemp <> "" Then
							strCurrentCell = Mid(arrGebizXL(1,1),1,1) + CStr(intRow)
							appXL.ActiveSheet.Range(strCurrentCell).Value = strTemp
							appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
							strTemp = ""
						End If
					End If
				End If
			
				'Get attachments
				Dim intAttachIndex
			
				intAttachIndex = 0
			
				intStart = FindString(intStart, "Attachments", strHTMLContents)
				If Not(IsNull(intStart)) Then
					intStart = FindString(intStart, "Description", strHTMLContents)
					If Not(IsNull(intStart)) Then
						For index = 0 To UBound(arrAttachments, 2)
							If Not(IsNull(FindString(intStart, arrAttachments(1,index), strHTMLContents))) Then
								'Check if folder is related to the html filename, if not attachments are assumed not meant for the related HTML ITQ
								If Not(IsNull(FindString(1, GetFileName(oFileName.Name), arrAttachments(0,index)))) Then
									strCurrentCell = Chr(cXLColForRelatedDocs + intAttachIndex) & CStr(intRow)
									strTemp = "=HYPERLINK(" & Chr(34) & cHttpLink & arrAttachments(0,index) & "/" & arrAttachments(1,index) & Chr(34) & "," & Chr(34) & arrAttachments(1,index) & Chr(34) & ")"
									appXL.ActiveSheet.Range(strCurrentCell).Value = strTemp
									appXL.ActiveSheet.Range(strCurrentCell).Font.Size = 9
									intAttachIndex = intAttachIndex + 1
									strTemp = ""
								End If
							End If
						Next
					End If
				End If
		
				intRow = intRow + 1
				oHTMLFile.Close
			
			End If
			
			On Error Goto 0
			
		End If
		
	End If

Next

Dim oRange

For index = Asc("B") To intColumnPointer
	Set oRange = appXL.Range(Chr(index) + "1")
	oRange.Activate
	Set oRange = appXL.ActiveCell.EntireColumn
	oRange.AutoFit()
Next

'Set A1 as active cell
Set oRange = appXL.Range(arrGebizXL(1,0))
oRange.Activate



appBook.SaveAs(strSourcePath & "\itq" & FormatFolderName + ".xls")
appBook.Close
DisconnectNetworkDrive(strDesDrive)
MsgBox "Done, results can be found in " & strSourcePath & "\itq" & FormatFolderName + ".xls"

'*******************************************
' Section for Subroutines and Functions
'*******************************************

'*******************************************
' Section for Subroutines and Functions
'*******************************************

'Creates folders, according to date, then copies files from source to destination
Function InitializeDesFolder(oFS, oSrcFolders, oDesFolders)

Dim strDesParentFolderPath, strWorkingFolderName, oNewFolder, strDesWorkingFolderPath

strDesParentFolderPath = oDesFolders.Path & FormatFolderName
strDesWorkingFolderPath = strDesParentFolderPath & "\ITQ"

If Not(oFS.FolderExists(strDesParentFolderPath)) Then
	Set oNewFolder = oFS.CreateFolder(strDesParentFolderPath)
	Set oNewFolder = Nothing
End If

If Not(oFS.FolderExists(strDesWorkingFolderPath)) Then
	Set oNewFolder = oFS.CreateFolder(strDesWorkingFolderPath)
End If

oFS.CopyFile oSrcFolders.Path & "\*", strDesWorkingFolderPath & "\" , True
oFS.CopyFolder oSrcFolders.Path & "\*", strDesWorkingFolderPath & "\" , True

InitializeDesFolder = strDesWorkingFolderPath  

End Function

'*******************************************

'Creates folders, according to date, then copies files from source to destination
Function InitializeTestFolder(oFS, oSrcFolders, oDesFolders)

Dim strDesParentFolderPath, strWorkingFolderName, oNewFolder, strDesWorkingFolderPath

strDesParentFolderPath = oDesFolders.Path & "Test"
strDesWorkingFolderPath = strDesParentFolderPath & "\ITQ"

If Not(oFS.FolderExists(strDesParentFolderPath)) Then
	Set oNewFolder = oFS.CreateFolder(strDesParentFolderPath)
	Set oNewFolder = Nothing
End If

If Not(oFS.FolderExists(strDesWorkingFolderPath)) Then
	Set oNewFolder = oFS.CreateFolder(strDesWorkingFolderPath)
End If

oFS.CopyFile oSrcFolders.Path & "\*", strDesWorkingFolderPath & "\" , True
oFS.CopyFolder oSrcFolders.Path & "\*", strDesWorkingFolderPath & "\" , True

InitializeTestFolder = strDesWorkingFolderPath  

End Function

'*************************************
'Get source folder from users
Function GetUserInput()

Dim oDlg, oSourceFolder, oFolderItem

Set oDlg = Wscript.CreateObject("Shell.Application")

Set oSourceFolder = oDlg.BrowseForFolder(&H0, "Select the folder where Gebiz files were downloaded", &H0001)

If InStr(1, TypeName(oSourceFolder), "Folder") > 0 Then
	Set oFolderItem = oSourceFolder.Self
	GetUserInput = oFolderItem.Path
Else
	GetUserInput = ""
End If

End Function

'*************************************
'Enumerates downloaded attachments associated with the ITQ. The Max
'no of attachment in the downloaded ITQ is returned 
Function GetAttachments(arrAttachments, oParentFolder)

Dim oFolder, oSubFolders, oFile, oFileName, index, intMaxAttach, intTemp

On Error Resume Next

intMaxAttach = 0
Set oSubFolders =  oParentFolder.SubFolders

For Each oFolder In oSubFolders
	intTemp = GetAttachments(arrAttachments, oFolder)
	If intTemp > intMaxAttach Then
		intMaxAttach = intTemp
	End If
Next

Set oFile = oParentFolder.Files

'Check if its first iteration
index = UBound(arrAttachments, 2)

If Err.number <> 0 Then 
	index = -1
End If

intTemp = 0

'Enumerate all attachments assuming as long as they are not HTML files they are attachments
For Each oFileName In oFile
	
	If Not(IsHTML(oFileName.Name)) And Not(IsHTMLComp(oFileName.Name)) Then
		index = index + 1
		intTemp = intTemp + 1
		ReDim Preserve arrAttachments(1, index)
		arrAttachments(0,index) = ConvertToRelativePath(oFileName.ParentFolder.Path)
		arrAttachments(1,index) = oFileName.Name
		If intTemp > intMaxAttach Then
			intMaxAttach = intTemp
		End If
	End If
	
Next

On Error Goto 0

If intMaxAttach > 17 Then
	GetAttachments = 17
Else
	GetAttachments = intMaxAttach
End If

End Function

'Converts DOS path to http relative path
Function ConvertToRelativePath(strPath)

Dim strTemp , re

If Len(strPath) <= 3 Then 
	ConvertToRelativePath = ""
	Exit Function
End If

strTemp = Mid(strPath,4,Len(strPath))

Set re = New RegExp
re.Pattern = "\\"
re.Global = True
re.IgnoreCase = True

strTemp = re.Replace(strTemp, "/") 

ConvertToRelativePath = strTemp

End Function

'*************************************
'Get a cell value from a HTML table
Function GetCellValue(intStartPt, strSearch)

Dim intNextPt

intNextPt = FindString(intStartPt, "<TD", strSearch)

If IsNull(intNextPt) Then
	GetCellValue = ""
Else
	GetCellValue = SearchForCell(intNextPt, strSearch)
End If

End Function

'Searches for a cell in a HTML table and returns the value in the cell
Function SearchForCell(intStartPt, strCell)

Dim intNext, strNextChar, intEndOfCell

intNext = FindString(intStartPt, ">", strCell)

If IsNull(intNext) or (intNext >= Len(strCell)) Then
	SearchForCell = ""
Else
	strNextChar = Mid(strCell, intNext+1,1)
	If (strNextChar = "<") Then
		SearchForCell = SearchForCell(intNext+1, strCell)
	Else
		intEndOfCell = FindString(intNext, "<", strCell)
		SearchForCell = Trim(Mid(strCell,intNext+1,intEndOfCell-intNext-1))
	End If

End If

End Function

'Replaces white space characters with just a space
Function Normalise(strToNormalise)

Dim re

Set re = New RegExp
re.Pattern = "\s+"
re.Global = True
re.IgnoreCase = True

strToNormalise = re.Replace(strToNormalise, " ")

re.Pattern = "\&amp;"

strToNormalise = re.Replace(strToNormalise, "&")

re.Pattern = "\&nbsp;"

Normalise = re.Replace(strToNormalise, " ")

End Function

'Add line feed every intMinLimit characters
Function WrapText(strOriginal, intMinLimit)

	Dim intLen, intCurrPt

	intLen = Len(strOriginal)

	If intLen <= intMinLimit Then
		WrapText = strOriginal
	Else
		intCurrPt = intMinLimit

		Do While Mid(strOriginal,intCurrPt,1) <> " " And intCurrPt < intLen
			intCurrPt = intCurrPt + 1
		Loop  
		
		If intCurrPt + 1 >= intLen Then 'If Next point in the string is the end of string
				WrapText = strOriginal
		Else		
				WrapText = Mid(strOriginal, 1, intCurrPt) + vbLf + WrapText(Mid(strOriginal,intCurrPt+1, intLen-intCurrPt+1), intMinLimit)
		End If
		
		
	End If

End Function

'**********************************************
' Function checks if file is a html file or not
' If yes true is returned, else false
'************************************************
Function IsHTML(strFileName)

If Not(IsNull(FindString(1, ".htm", strFileName))) Then
	IsHTML = True
ElseIf  Not(IsNull(FindString(1, ".html", strFileName))) Then
	IsHTML = True
Else
	IsHTML = False
End If


End Function

'**********************************************
' Function checks if file is a picture or script 
' attachment in a html file or not
' If yes true is returned, else false
'************************************************
Function IsHTMLComp(strName)

Dim arrComp(14), i

arrComp(0) = "2005_index_banner.jpg"
arrComp(1) = "2005_logo_partner.gif"
arrComp(2) = "arr_rgt2.gif"
arrComp(3) = "clear.gif"
arrComp(4) = "folder.gif"
arrComp(5) = "header_tab_line.gif"
arrComp(6) = "icon_howto.gif"
arrComp(7) = "partner_2005.css"
arrComp(8) = "singov_top_02.gif"
arrComp(9) = "Thumbs.db"
arrComp(10) = "treecollapsedMidNode.gif"
arrComp(11) = "treeexpandedMidNode.gif"
arrComp(12) = "treenoChildrenLastNode.gif"
arrComp(13) = "treenoChildrenMidNode.gif"
arrComp(14) = "treeverticalLine.gif"

For i=0 to UBound(arrComp)
	If strName = arrComp(i) Then
		IsHTMLComp = True
		Exit For
	Else
		IsHTMLComp = False
	End If
Next

End Function

'*************************************************************************
' Desc:	The function finds the string specified in strToFind. If its not found
'	Null is returned, else the first position where the string is found
'	is returned 
'*************************************************************************
Function FindString(intStart, strToFind, strSource)

Dim intLast

intLast = InStr(intStart, LCase(strSource), LCase(strToFind))

If (intLast <= 0) Or IsNull(intLast) Then
	FindString = Null
Else
	FindString = intLast
End If

End Function

  '************************************************'
  'Desc:	The function returns maps a drive to the specified 
  '		network share. If strID (userID) and strPwd (Password)
  '		is Null the currently logged on credentials are used. 
  '		If bUpdateProfie is true the current profile is updated 
  '		else no update is done. 
  '		It returns the mapped drive. 
  '		A Null will be returned when an error occurs
  '****************************************************
  
  Function MapFreeDrive(strUNC, bUpdateProfile, strID, strPwd)
  
  	Dim oFSO, oNet, strDrive

	On Error Resume Next
	
  	Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
  	Set oNet = WScript.CreateObject("WScript.Network")
  
  	strDrive = GetFreeDrive(oFSO)
   
  	If IsNull(strDrive) Then
  		MapFreeDrive = Null
  		Exit Function
  	End If
  
  	If IsNull(strID) or IsNull(strPwd) Then
  		oNet.MapNetworkDrive strDrive, strUNC, bUpdateProfile
  	Else
  		oNet.MapNetworkDrive strDrive, strUNC, bUpdateProfile, strID, strPwd
  	End If  
  
  	If Err.number <> 0 Then
  		MapFreeDrive = Null
  	Else
  		MapFreeDrive = strDrive
  	End If
  	
  	Set oFSO = Nothing
  	Set oNet = Nothing  
  
	On Error Goto 0
  
  End Function

  '************************************************'
  'Desc:	The sub routine disconnects a network drive
  '		specified in strDrive
  '****************************************************
  Sub DisconnectNetworkDrive(strDrive)
  
  	Dim oNet, oFSO
  
  	Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
    	
    	If oFSO.DriveExists(Left(strDrive,1)) Then
    	 	Set oNet = WScript.CreateObject("WScript.Network")
  		oNet.RemoveNetworkDrive strDrive
  	Else
  		Exit Sub
  	End If 
    
  End Sub
 
  '************************************************'
  'Desc:	The function returns a free drive that is unused
  '			A Null will be returned when an error occurs
  '****************************************************  
  
  Function GetFreeDrive(ByRef oFS)
  
	Dim intDrive
  
	intDrive = 72 'Start with drive H:
		  
	Do While (intDrive <= 90)
	
		If oFS.DriveExists(Chr(intDrive)) Then
			intDrive = intDrive + 1
		Else
			GetFreeDrive = Chr(intDrive) & ":"
			Exit Function
		End If
	
	Loop 
	
	GetFreeDrive = Null
	  
  End Function
  
  
  
'***************************************************************************
'Desc		The function returns a folder name, formated according to the  
'		current the date.
'***************************************************************************

Function FormatFolderName
  
Dim strFileName
  	
If (Day(Date)< 10) Then
	strFileName = "0" & CStr(Day(Date))
Else
  	strFileName = CStr(Day(Date))
End If
  	
If (Month(Date)< 10) Then
	strFileName = strFileName & "0" & CStr(Month(Date))
Else
  	strFileName = strFileName & CStr(Month(Date))
End If
  	
strFileName = strFileName & Year(Date)
  	
FormatFolderName = strFileName
    
End Function

'Formats date in dd-mmmm-yyyy format
Function FormatDate(strDate)

Dim dtmTemp, strNewDateFormat

dtmTemp = DateValue(strDate)

If (Day(dtmTemp)< 10) Then
	strNewDateFormat = "0" & CStr(Day(dtmTemp)) & "-"
Else 
	strNewDateFormat = CStr(Day(dtmTemp)) & "-"
End If

strNewDateFormat = strNewDateFormat & CStr(MonthName(Month(dtmTemp), True)) & "-"
strNewDateFormat = strNewDateFormat & CStr(Year(dtmTemp))

FormatDate = strNewDateFormat


End Function

'Formats date in dd-mmmm-yyyy hh:mm:ss format
Function FormatDateTime(strDateTime)

Dim strNewDateTime, intMarker, strOldFormat

strOldFormat = Trim(strDateTime)

intMarker = FindString(1, " ", strOldFormat)
If IsNull(intMarker) Then
	FormatDateTime = ""
Else
	strNewDateTime = " " & FormatDate(Mid(strOldFormat,1,intMarker-1))
	strNewDateTime = strNewDateTime & " " & Mid(strOldFormat, intMarker + 1, Len(strOldFormat))
	FormatDateTime = strNewDateTime
End If



End Function

  '**************************************************'
  'Desc:	The function returns the extensiom without  
  '			the filename. 
  '****************************************************
  
  Function GetFileExtension(strExt)
  
	Dim strTemp
  
	strTemp = Trim(strExt)
	GetFileExtension = Mid(strTemp, InStrRev(strTemp, ".")+1,Len(strTemp))
	  
  End Function
  
    '**************************************************'
  'Desc:	The function returns the filename without  
  '		the extension. 
  '****************************************************
  
  Function GetFileName(strName)
  
	Dim strTemp
  
	strTemp = Trim(strName)
	GetFileName = Mid(strTemp,1,InStr(1,strName,".")-1)
	
  End Function